home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / sport.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-06-13  |  5.7 KB  |  207 lines
  1. /*
  2.  * s p o r t . c            -- String ports management
  3.  *
  4.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5.  * 
  6.  *
  7.  * Permission to use, copy, and/or distribute this software and its
  8.  * documentation for any purpose and without fee is hereby granted, provided
  9.  * that both the above copyright notice and this permission notice appear in
  10.  * all copies and derived works.  Fees for distribution or use of this
  11.  * software or derived works may only be charged with express written
  12.  * permission of the copyright holder.  
  13.  * This software is provided ``as is'' without express or implied warranty.
  14.  *
  15.  * This software is a derivative work of other copyrighted softwares; the
  16.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  17.  *
  18.  *
  19.  *            Author: Erick Gallesio [eg@unice.fr]
  20.  *    Creation date: 17-Feb-1993 12:27
  21.  * Last file update: 13-Jun-1996 18:24
  22.  *
  23.  *
  24.  * This is achieved in a (surely very) dependant way. A string port is implemented
  25.  * via a pseudo FILE descriptor malloc'd when open-input-string is called. This 
  26.  * descriptor is released when free-string-port is called.
  27.  */
  28.  
  29. #include "stk.h"
  30. #include "sport.h"
  31.  
  32. SCM STk_internal_open_input_string(char *str)
  33. {
  34.   struct str_iob *p;
  35.   SCM z;
  36.  
  37.   p = (struct str_iob *) must_malloc(sizeof (struct str_iob));
  38.   
  39.   p->signature = SPORT_SIGNATURE;
  40.   p->flag      = READING;
  41.   p->cnt       = p->bufsiz = strlen(str);
  42.   p->base      = p->ptr    = must_malloc(p->cnt + 1);
  43.   strcpy(p->base, str);
  44.  
  45.   /* Sport_descr is a short version of a port_descr */
  46.   NEWCELL(z, tc_isport);
  47.   z->storage_as.port.p   = (struct port_descr *) 
  48.                 must_malloc(sizeof(struct sport_descr));
  49.   PORT_FILE(z)           = (FILE *) p;
  50.   PORT_FLAGS(z)          = 0;
  51.  
  52.   return z;
  53. }
  54.  
  55. void STk_free_string_port(SCM port)
  56. {
  57.   struct str_iob * p;
  58.  
  59.   p = (struct str_iob *) PORT_FILE(port);
  60.   free(p->base);
  61.   free(p);
  62.   free(port->storage_as.port.p);
  63. }
  64.  
  65. SCM STk_internal_read_from_string(SCM port, int *eof, int case_significant)
  66. {
  67.   jmp_buf jb, *prev_jb = Top_jmp_buf;
  68.   long prev_context     = Error_context;
  69.   SCM result;
  70.   int k;
  71.  
  72.   /* save normal error jmpbuf  so that read error don't lead to toplevel */
  73.   /* If in a "catch", keep the ERR_IGNORED bit set */
  74.   if ((k = setjmp(jb)) == 0) {
  75.     Top_jmp_buf   = &jb;
  76.     Error_context = (Error_context & ERR_IGNORED) | ERR_READ_FROM_STRING;
  77.     result       = STk_readf(PORT_FILE(port), case_significant);
  78.     *eof         = Eof(PORT_FILE(port));
  79.   }
  80.   Top_jmp_buf   = prev_jb;;
  81.   Error_context = prev_context;
  82.   
  83.   if (k == 0) return result;
  84.   
  85.   /* if we are here, an error has occured during the string reading 
  86.    * Two cases:
  87.    *    - we are in a catch. Do a longjump to the catch to signal it a fail
  88.    *    - otherwise error has already signaled, just return EVAL_ERROR
  89.    */
  90.   if (Error_context & ERR_IGNORED) longjmp(*Top_jmp_buf, k);
  91.   return EVAL_ERROR;
  92. }
  93.  
  94. PRIMITIVE STk_open_input_string(SCM s)
  95. {
  96.   if (NSTRINGP(s)) Err("open-input-string: not a string", s);
  97.   return STk_internal_open_input_string(CHARS(s));
  98. }
  99.  
  100.  
  101. PRIMITIVE STk_open_output_string()
  102. {
  103.   struct str_iob *p;
  104.   SCM z;
  105.  
  106.   p = (struct str_iob *) must_malloc(sizeof (struct str_iob));
  107.  
  108.   p->signature = SPORT_SIGNATURE;
  109.   p->flag      = WRITING;
  110.   p->cnt       = 0;
  111.   p->bufsiz    = START_ALLOC;
  112.   p->base      = p->ptr = (char *) must_malloc(START_ALLOC);
  113.  
  114.   NEWCELL(z, tc_osport);
  115.   z->storage_as.port.p   = (struct port_descr *) 
  116.                     must_malloc(sizeof(struct sport_descr));
  117.   PORT_FILE(z)           = (FILE *) p;
  118.   PORT_FLAGS(z)          = 0;
  119.  
  120.   return z;
  121. }
  122.  
  123. PRIMITIVE STk_get_output_string(SCM port)
  124. {
  125.   if (NOSPORTP(port)) Err("get-output-string: Bad string-port", port);
  126.   if (PORT_FLAGS(port) & PORT_CLOSED) 
  127.     Err("get-output-string: string port is closed", port);
  128.  
  129.   return STk_makestrg(((struct str_iob *)PORT_FILE(port))->cnt, 
  130.               ((struct str_iob *)PORT_FILE(port))->base);
  131. }
  132.  
  133. PRIMITIVE STk_input_string_portp(SCM port)
  134. {
  135.   return (ISPORTP(port)) ? Truth: Ntruth;
  136. }
  137.  
  138. PRIMITIVE STk_output_string_portp(SCM port)
  139. {
  140.   return (OSPORTP(port)) ? Truth: Ntruth;
  141. }
  142.  
  143. PRIMITIVE STk_with_input_from_string(SCM string, SCM thunk)
  144. {
  145.   jmp_buf env, *prev_env = Top_jmp_buf;
  146.   SCM result, prev_iport = STk_curr_iport;
  147.   int prev_context     = Error_context;
  148.   int k;
  149.  
  150.   if (NSTRINGP(string))     Err("with-input-from-string: bad string", string);
  151.   if (!STk_is_thunk(thunk)) Err("with-input-from-string: bad thunk", thunk);
  152.  
  153.   if ((k = setjmp(env)) == 0) {
  154.     Top_jmp_buf    = &env;
  155.     STk_curr_iport = STk_internal_open_input_string(CHARS(string));
  156.     result         = Apply(thunk, NIL);
  157.   }
  158.   /* restore normal error jmpbuf  and current input port*/
  159.   STk_curr_iport = prev_iport;
  160.   Top_jmp_buf    = prev_env;
  161.   Error_context  = prev_context;
  162.  
  163.   if (k) /*propagate error */ longjmp(*Top_jmp_buf, k);
  164.   return result;
  165. }
  166.  
  167. PRIMITIVE STk_with_output_to_string(SCM thunk)
  168. {
  169.   jmp_buf env, *prev_env = Top_jmp_buf;
  170.   SCM result, prev_oport = STk_curr_oport;
  171.   int prev_context       = Error_context;
  172.   int k;
  173.  
  174.   if (!STk_is_thunk(thunk)) Err("with-output-to-string: bad thunk", thunk);
  175.  
  176.   if ((k = setjmp(env)) == 0) {
  177.     Top_jmp_buf    = &env;
  178.     STk_curr_oport = STk_open_output_string();
  179.     Apply(thunk, NIL);
  180.     result         = STk_get_output_string(STk_curr_oport);
  181.   }
  182.   /* restore normal error jmpbuf  and current input port*/
  183.   STk_curr_oport = prev_oport;
  184.   Top_jmp_buf    = prev_env;
  185.   Error_context  = prev_context;
  186.  
  187.   if (k) /*propagate error */ longjmp(*Top_jmp_buf, k);
  188.   return result;
  189. }
  190.  
  191.  
  192. PRIMITIVE STk_read_from_string(SCM str)
  193. {
  194.   SCM result, port;
  195.   int eof;    /* not used here */
  196.  
  197.   if (NSTRINGP(str)) Err("read-from-string: Bad string", str);
  198.  
  199.   /* Create a string port to read in the expression */
  200.   port   = STk_internal_open_input_string(CHARS(str));
  201.   result = STk_internal_read_from_string(port, &eof, FALSE);
  202.  
  203.   return result == EVAL_ERROR? UNDEFINED: result;
  204. }
  205.  
  206.  
  207.